{-# LANGUAGE FlexibleContexts #-}

module Language.ATS.Rewrite ( rewriteDecl
                            -- * Fixity
                            , defaultFixityState
                            ) where

import           Control.Composition
import           Control.Recursion
import qualified Data.Map                as M
import           Data.Maybe              (isJust)
import           Language.ATS.Types
import           Language.ATS.Types.Lens
import           Lens.Micro

exprLens :: Eq a => FixityState a -> ASetter s t (Expression a) (Expression a) -> s -> t
exprLens :: FixityState a
-> ASetter s t (Expression a) (Expression a) -> s -> t
exprLens = (ASetter s t (Expression a) (Expression a)
 -> (Expression a -> Expression a) -> s -> t)
-> (Expression a -> Expression a)
-> ASetter s t (Expression a) (Expression a)
-> s
-> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip ASetter s t (Expression a) (Expression a)
-> (Expression a -> Expression a) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Expression a -> Expression a)
 -> ASetter s t (Expression a) (Expression a) -> s -> t)
-> (FixityState a -> Expression a -> Expression a)
-> FixityState a
-> ASetter s t (Expression a) (Expression a)
-> s
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixityState a -> Expression a -> Expression a
forall a. Eq a => FixityState a -> Expression a -> Expression a
rewriteATS

exprStaLens :: Eq a => FixityState a -> ASetter s t (StaticExpression a) (StaticExpression a) -> s -> t
exprStaLens :: FixityState a
-> ASetter s t (StaticExpression a) (StaticExpression a) -> s -> t
exprStaLens = (ASetter s t (StaticExpression a) (StaticExpression a)
 -> (StaticExpression a -> StaticExpression a) -> s -> t)
-> (StaticExpression a -> StaticExpression a)
-> ASetter s t (StaticExpression a) (StaticExpression a)
-> s
-> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip ASetter s t (StaticExpression a) (StaticExpression a)
-> (StaticExpression a -> StaticExpression a) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((StaticExpression a -> StaticExpression a)
 -> ASetter s t (StaticExpression a) (StaticExpression a) -> s -> t)
-> (FixityState a -> StaticExpression a -> StaticExpression a)
-> FixityState a
-> ASetter s t (StaticExpression a) (StaticExpression a)
-> s
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixityState a -> StaticExpression a -> StaticExpression a
forall a.
Eq a =>
FixityState a -> StaticExpression a -> StaticExpression a
rewriteStaATS

exprLenses :: Eq a => FixityState a -> [ASetter b b (Expression a) (Expression a)] -> b -> b
exprLenses :: FixityState a
-> [ASetter b b (Expression a) (Expression a)] -> b -> b
exprLenses FixityState a
st = [b -> b] -> b -> b
forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread ([b -> b] -> b -> b)
-> ([ASetter b b (Expression a) (Expression a)] -> [b -> b])
-> [ASetter b b (Expression a) (Expression a)]
-> b
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASetter b b (Expression a) (Expression a) -> b -> b)
-> [ASetter b b (Expression a) (Expression a)] -> [b -> b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FixityState a
-> ASetter b b (Expression a) (Expression a) -> b -> b
forall a s t.
Eq a =>
FixityState a
-> ASetter s t (Expression a) (Expression a) -> s -> t
exprLens FixityState a
st)

rewriteDecl :: Eq a => FixityState a -> Declaration a -> Declaration a
rewriteDecl :: FixityState a -> Declaration a -> Declaration a
rewriteDecl FixityState a
st (Extern a
l Declaration a
d) = a -> Declaration a -> Declaration a
forall a. a -> Declaration a -> Declaration a
Extern a
l (FixityState a -> Declaration a -> Declaration a
forall a. Eq a => FixityState a -> Declaration a -> Declaration a
rewriteDecl FixityState a
st Declaration a
d)
rewriteDecl FixityState a
st x :: Declaration a
x@Val{} = FixityState a
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
-> Declaration a
-> Declaration a
forall a s t.
Eq a =>
FixityState a
-> ASetter s t (Expression a) (Expression a) -> s -> t
exprLens FixityState a
st ((Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (Maybe (Expression a))
valExpression((Maybe (Expression a) -> Identity (Maybe (Expression a)))
 -> Declaration a -> Identity (Declaration a))
-> ((Expression a -> Identity (Expression a))
    -> Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Expression a -> Identity (Expression a))
-> Maybe (Expression a) -> Identity (Maybe (Expression a))
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just) Declaration a
x
rewriteDecl FixityState a
st x :: Declaration a
x@Var{} = FixityState a
-> [ASetter
      (Declaration a) (Declaration a) (Expression a) (Expression a)]
-> Declaration a
-> Declaration a
forall a b.
Eq a =>
FixityState a
-> [ASetter b b (Expression a) (Expression a)] -> b -> b
exprLenses FixityState a
st [(Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (Maybe (Expression a))
varExpr1((Maybe (Expression a) -> Identity (Maybe (Expression a)))
 -> Declaration a -> Identity (Declaration a))
-> ((Expression a -> Identity (Expression a))
    -> Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Expression a -> Identity (Expression a))
-> Maybe (Expression a) -> Identity (Maybe (Expression a))
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just, (Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (Maybe (Expression a))
varExpr2((Maybe (Expression a) -> Identity (Maybe (Expression a)))
 -> Declaration a -> Identity (Declaration a))
-> ((Expression a -> Identity (Expression a))
    -> Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Expression a -> Identity (Expression a))
-> Maybe (Expression a) -> Identity (Maybe (Expression a))
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just] Declaration a
x
rewriteDecl FixityState a
st x :: Declaration a
x@PrVal{} = FixityState a
-> ASetter
     (Declaration a)
     (Declaration a)
     (StaticExpression a)
     (StaticExpression a)
-> Declaration a
-> Declaration a
forall a s t.
Eq a =>
FixityState a
-> ASetter s t (StaticExpression a) (StaticExpression a) -> s -> t
exprStaLens FixityState a
st ((Maybe (StaticExpression a)
 -> Identity (Maybe (StaticExpression a)))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (Maybe (StaticExpression a))
prValExpr((Maybe (StaticExpression a)
  -> Identity (Maybe (StaticExpression a)))
 -> Declaration a -> Identity (Declaration a))
-> ((StaticExpression a -> Identity (StaticExpression a))
    -> Maybe (StaticExpression a)
    -> Identity (Maybe (StaticExpression a)))
-> ASetter
     (Declaration a)
     (Declaration a)
     (StaticExpression a)
     (StaticExpression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StaticExpression a -> Identity (StaticExpression a))
-> Maybe (StaticExpression a)
-> Identity (Maybe (StaticExpression a))
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just) Declaration a
x
rewriteDecl FixityState a
st x :: Declaration a
x@PrVar{} = FixityState a
-> ASetter
     (Declaration a)
     (Declaration a)
     (StaticExpression a)
     (StaticExpression a)
-> Declaration a
-> Declaration a
forall a s t.
Eq a =>
FixityState a
-> ASetter s t (StaticExpression a) (StaticExpression a) -> s -> t
exprStaLens FixityState a
st ((Maybe (StaticExpression a)
 -> Identity (Maybe (StaticExpression a)))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (Maybe (StaticExpression a))
prValExpr((Maybe (StaticExpression a)
  -> Identity (Maybe (StaticExpression a)))
 -> Declaration a -> Identity (Declaration a))
-> ((StaticExpression a -> Identity (StaticExpression a))
    -> Maybe (StaticExpression a)
    -> Identity (Maybe (StaticExpression a)))
-> ASetter
     (Declaration a)
     (Declaration a)
     (StaticExpression a)
     (StaticExpression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StaticExpression a -> Identity (StaticExpression a))
-> Maybe (StaticExpression a)
-> Identity (Maybe (StaticExpression a))
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just) Declaration a
x
rewriteDecl FixityState a
st x :: Declaration a
x@Func{} = FixityState a
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
-> Declaration a
-> Declaration a
forall a s t.
Eq a =>
FixityState a
-> ASetter s t (Expression a) (Expression a) -> s -> t
exprLens FixityState a
st ((Function a -> Identity (Function a))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (Function a)
fun((Function a -> Identity (Function a))
 -> Declaration a -> Identity (Declaration a))
-> ((Expression a -> Identity (Expression a))
    -> Function a -> Identity (Function a))
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PreFunction Expression a -> Identity (PreFunction Expression a))
-> Function a -> Identity (Function a)
forall a. Traversal' (Function a) (PreFunction Expression a)
preF((PreFunction Expression a -> Identity (PreFunction Expression a))
 -> Function a -> Identity (Function a))
-> ((Expression a -> Identity (Expression a))
    -> PreFunction Expression a -> Identity (PreFunction Expression a))
-> (Expression a -> Identity (Expression a))
-> Function a
-> Identity (Function a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> PreFunction Expression a -> Identity (PreFunction Expression a)
forall (ek :: * -> *) a. Lens' (PreFunction ek a) (Maybe (ek a))
expression((Maybe (Expression a) -> Identity (Maybe (Expression a)))
 -> PreFunction Expression a -> Identity (PreFunction Expression a))
-> ((Expression a -> Identity (Expression a))
    -> Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> (Expression a -> Identity (Expression a))
-> PreFunction Expression a
-> Identity (PreFunction Expression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Expression a -> Identity (Expression a))
-> Maybe (Expression a) -> Identity (Maybe (Expression a))
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just) Declaration a
x
rewriteDecl FixityState a
st x :: Declaration a
x@Impl{} = FixityState a
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
-> Declaration a
-> Declaration a
forall a s t.
Eq a =>
FixityState a
-> ASetter s t (Expression a) (Expression a) -> s -> t
exprLens FixityState a
st ((Implementation a -> Identity (Implementation a))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (Implementation a)
impl((Implementation a -> Identity (Implementation a))
 -> Declaration a -> Identity (Declaration a))
-> ((Expression a -> Identity (Expression a))
    -> Implementation a -> Identity (Implementation a))
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Either (StaticExpression a) (Expression a)
 -> Identity (Either (StaticExpression a) (Expression a)))
-> Implementation a -> Identity (Implementation a)
forall a.
Lens'
  (Implementation a) (Either (StaticExpression a) (Expression a))
iExpression((Either (StaticExpression a) (Expression a)
  -> Identity (Either (StaticExpression a) (Expression a)))
 -> Implementation a -> Identity (Implementation a))
-> ((Expression a -> Identity (Expression a))
    -> Either (StaticExpression a) (Expression a)
    -> Identity (Either (StaticExpression a) (Expression a)))
-> (Expression a -> Identity (Expression a))
-> Implementation a
-> Identity (Implementation a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Expression a -> Identity (Expression a))
-> Either (StaticExpression a) (Expression a)
-> Identity (Either (StaticExpression a) (Expression a))
forall a b b'. Traversal (Either a b) (Either a b') b b'
_Right) Declaration a
x
rewriteDecl FixityState a
st x :: Declaration a
x@AndDecl{} = FixityState a
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
-> Declaration a
-> Declaration a
forall a s t.
Eq a =>
FixityState a
-> ASetter s t (Expression a) (Expression a) -> s -> t
exprLens FixityState a
st ASetter
  (Declaration a) (Declaration a) (Expression a) (Expression a)
forall a. Traversal' (Declaration a) (Expression a)
andExpr Declaration a
x
rewriteDecl FixityState a
st x :: Declaration a
x@DataProp{} = FixityState a
-> [ASetter
      (Declaration a) (Declaration a) (Expression a) (Expression a)]
-> Declaration a
-> Declaration a
forall a b.
Eq a =>
FixityState a
-> [ASetter b b (Expression a) (Expression a)] -> b -> b
exprLenses FixityState a
st ((((Expression a -> Identity (Expression a))
  -> DataPropLeaf a -> Identity (DataPropLeaf a))
 -> ASetter
      (Declaration a) (Declaration a) (Expression a) (Expression a))
-> [(Expression a -> Identity (Expression a))
    -> DataPropLeaf a -> Identity (DataPropLeaf a)]
-> [ASetter
      (Declaration a) (Declaration a) (Expression a) (Expression a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([DataPropLeaf a] -> Identity [DataPropLeaf a])
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) [DataPropLeaf a]
propLeaves(([DataPropLeaf a] -> Identity [DataPropLeaf a])
 -> Declaration a -> Identity (Declaration a))
-> ((DataPropLeaf a -> Identity (DataPropLeaf a))
    -> [DataPropLeaf a] -> Identity [DataPropLeaf a])
-> (DataPropLeaf a -> Identity (DataPropLeaf a))
-> Declaration a
-> Identity (Declaration a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(DataPropLeaf a -> Identity (DataPropLeaf a))
-> [DataPropLeaf a] -> Identity [DataPropLeaf a]
forall s t a b. Each s t a b => Traversal s t a b
each)((DataPropLeaf a -> Identity (DataPropLeaf a))
 -> Declaration a -> Identity (Declaration a))
-> ((Expression a -> Identity (Expression a))
    -> DataPropLeaf a -> Identity (DataPropLeaf a))
-> ASetter
     (Declaration a) (Declaration a) (Expression a) (Expression a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) [(Expression a -> Identity (Expression a))
-> DataPropLeaf a -> Identity (DataPropLeaf a)
forall a. Lens' (DataPropLeaf a) (Expression a)
propExpr1, (Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> DataPropLeaf a -> Identity (DataPropLeaf a)
forall a. Lens' (DataPropLeaf a) (Maybe (Expression a))
propExpr2((Maybe (Expression a) -> Identity (Maybe (Expression a)))
 -> DataPropLeaf a -> Identity (DataPropLeaf a))
-> ((Expression a -> Identity (Expression a))
    -> Maybe (Expression a) -> Identity (Maybe (Expression a)))
-> (Expression a -> Identity (Expression a))
-> DataPropLeaf a
-> Identity (DataPropLeaf a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Expression a -> Identity (Expression a))
-> Maybe (Expression a) -> Identity (Maybe (Expression a))
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just]) Declaration a
x
rewriteDecl FixityState a
_ x :: Declaration a
x@SumViewType{} = Declaration a -> Declaration a
g Declaration a
x
    where g :: Declaration a -> Declaration a
g = ASetter (Declaration a) (Declaration a) [Universal a] [Universal a]
-> ([Universal a] -> [Universal a])
-> Declaration a
-> Declaration a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((NonEmpty (Leaf a) -> Identity (NonEmpty (Leaf a)))
-> Declaration a -> Identity (Declaration a)
forall a. Traversal' (Declaration a) (NonEmpty (Leaf a))
leaves((NonEmpty (Leaf a) -> Identity (NonEmpty (Leaf a)))
 -> Declaration a -> Identity (Declaration a))
-> (([Universal a] -> Identity [Universal a])
    -> NonEmpty (Leaf a) -> Identity (NonEmpty (Leaf a)))
-> ASetter
     (Declaration a) (Declaration a) [Universal a] [Universal a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ASetter (NonEmpty (Leaf a)) (NonEmpty (Leaf a)) (Leaf a) (Leaf a)
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mappedASetter (NonEmpty (Leaf a)) (NonEmpty (Leaf a)) (Leaf a) (Leaf a)
-> (([Universal a] -> Identity [Universal a])
    -> Leaf a -> Identity (Leaf a))
-> ([Universal a] -> Identity [Universal a])
-> NonEmpty (Leaf a)
-> Identity (NonEmpty (Leaf a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Universal a] -> Identity [Universal a])
-> Leaf a -> Identity (Leaf a)
forall a. Lens' (Leaf a) [Universal a]
constructorUniversals) [Universal a] -> [Universal a]
forall a. Eq a => [Universal a] -> [Universal a]
h
          h :: Eq a => [Universal a] -> [Universal a]
          h :: [Universal a] -> [Universal a]
h = ([Universal a] -> Base [Universal a] [Universal a])
-> [Universal a] -> [Universal a]
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana [Universal a] -> Base [Universal a] [Universal a]
forall a.
Eq a =>
[Universal a] -> ListF (Universal a) [Universal a]
c where
            c :: [Universal a] -> ListF (Universal a) [Universal a]
c (Universal a
y:Universal a
y':[Universal a]
ys)
                | Universal a -> Maybe (Sort a)
forall a. Universal a -> Maybe (Sort a)
typeU Universal a
y Maybe (Sort a) -> Maybe (Sort a) -> Bool
forall a. Eq a => a -> a -> Bool
== Universal a -> Maybe (Sort a)
forall a. Universal a -> Maybe (Sort a)
typeU Universal a
y' Bool -> Bool -> Bool
&& Maybe (Sort a) -> Bool
forall a. Maybe a -> Bool
isJust (Universal a -> Maybe (Sort a)
forall a. Universal a -> Maybe (Sort a)
typeU Universal a
y) =
                    Universal a -> [Universal a] -> ListF (Universal a) [Universal a]
forall a b. a -> b -> ListF a b
Cons ([String] -> Maybe (Sort a) -> [StaticExpression a] -> Universal a
forall a.
[String] -> Maybe (Sort a) -> [StaticExpression a] -> Universal a
Universal (Universal a -> [String]
forall a. Universal a -> [String]
bound Universal a
y [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Universal a -> [String]
forall a. Universal a -> [String]
bound Universal a
y') (Universal a -> Maybe (Sort a)
forall a. Universal a -> Maybe (Sort a)
typeU Universal a
y) (BinOp a
-> StaticExpression a -> StaticExpression a -> StaticExpression a
forall a.
BinOp a
-> StaticExpression a -> StaticExpression a -> StaticExpression a
StaticBinary BinOp a
forall a. BinOp a
LogicalAnd (StaticExpression a -> StaticExpression a -> StaticExpression a)
-> [StaticExpression a]
-> [StaticExpression a -> StaticExpression a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Universal a -> [StaticExpression a]
forall a. Universal a -> [StaticExpression a]
prop Universal a
y [StaticExpression a -> StaticExpression a]
-> [StaticExpression a] -> [StaticExpression a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Universal a -> [StaticExpression a]
forall a. Universal a -> [StaticExpression a]
prop Universal a
y')) [Universal a]
ys
            c [Universal a]
y = [Universal a] -> Base [Universal a] [Universal a]
forall t. Recursive t => t -> Base t t
project [Universal a]
y
rewriteDecl FixityState a
_ Declaration a
x = Declaration a
x

-- | Fixities for operators in the ATS prelude.
defaultFixityState :: FixityState a
defaultFixityState :: FixityState a
defaultFixityState = [(String, Fixity a)] -> FixityState a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ (String
"::", Int -> Fixity a
forall a. Int -> Fixity a
rightFix Int
40) ]

leftFix :: Int -> Fixity a
leftFix :: Int -> Fixity a
leftFix = a -> Fix -> Fixity a
forall a. a -> Fix -> Fixity a
LeftFix a
forall a. HasCallStack => a
undefined (Fix -> Fixity a) -> (Int -> Fix) -> Int -> Fixity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Fix
forall a b. a -> Either a b
Left

rightFix :: Int -> Fixity a
rightFix :: Int -> Fixity a
rightFix = a -> Fix -> Fixity a
forall a. a -> Fix -> Fixity a
RightFix a
forall a. HasCallStack => a
undefined (Fix -> Fixity a) -> (Int -> Fix) -> Int -> Fixity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Fix
forall a b. a -> Either a b
Left

infix_ :: Int -> Fixity a
infix_ :: Int -> Fixity a
infix_ = a -> Fix -> Fixity a
forall a. a -> Fix -> Fixity a
Infix a
forall a. HasCallStack => a
undefined (Fix -> Fixity a) -> (Int -> Fix) -> Int -> Fixity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Fix
forall a b. a -> Either a b
Left

-- | Default fixities from @fixity.ats@
getFixity :: FixityState a -> BinOp a -> Fixity a
getFixity :: FixityState a -> BinOp a -> Fixity a
getFixity FixityState a
_ BinOp a
Add                   = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
50
getFixity FixityState a
_ BinOp a
Sub                   = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
50
getFixity FixityState a
_ BinOp a
Mutate                = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
0
getFixity FixityState a
_ BinOp a
Mult                  = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
60
getFixity FixityState a
_ BinOp a
Div                   = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
60
getFixity FixityState a
_ BinOp a
SpearOp               = Int -> Fixity a
forall a. Int -> Fixity a
rightFix Int
10
getFixity FixityState a
_ BinOp a
LogicalAnd            = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
21
getFixity FixityState a
_ BinOp a
LogicalOr             = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
20
getFixity FixityState a
_ BinOp a
At                    = Int -> Fixity a
forall a. Int -> Fixity a
rightFix Int
40
getFixity FixityState a
_ BinOp a
GreaterThan           = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
40
getFixity FixityState a
_ BinOp a
GreaterThanEq         = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
40
getFixity FixityState a
_ BinOp a
LessThanEq            = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
40
getFixity FixityState a
_ BinOp a
Equal                 = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
30
getFixity FixityState a
_ BinOp a
NotEq                 = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
30
getFixity FixityState a
_ BinOp a
StaticEq              = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
30
getFixity FixityState a
_ BinOp a
Mod                   = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
60
getFixity FixityState a
_ BinOp a
LessThan              = Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
40
getFixity FixityState a
_ BinOp a
LShift                = Int -> Fixity a
forall a. Int -> Fixity a
leftFix Int
0
getFixity FixityState a
_ BinOp a
RShift                = Int -> Fixity a
forall a. Int -> Fixity a
rightFix Int
0
getFixity FixityState a
st (SpecialInfix a
_ String
op') =
    case String -> FixityState a -> Maybe (Fixity a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
op' FixityState a
st of
        (Just Fixity a
f) -> Fixity a
f
        Maybe (Fixity a)
Nothing  -> Int -> Fixity a
forall a. Int -> Fixity a
infix_ Int
100

-- FIXME this should account for right vs. left associativity.
compareFixity :: Eq a => FixityState a -> BinOp a -> BinOp a -> Bool
compareFixity :: FixityState a -> BinOp a -> BinOp a -> Bool
compareFixity FixityState a
st = (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT) (Ordering -> Bool)
-> (BinOp a -> BinOp a -> Ordering) -> BinOp a -> BinOp a -> Bool
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* (Fixity a -> Fixity a -> Ordering)
-> (BinOp a -> Fixity a) -> BinOp a -> BinOp a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Fixity a -> Fixity a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FixityState a -> BinOp a -> Fixity a
forall a. FixityState a -> BinOp a -> Fixity a
getFixity FixityState a
st)

rewriteStaATS :: Eq a => FixityState a -> StaticExpression a -> StaticExpression a
rewriteStaATS :: FixityState a -> StaticExpression a -> StaticExpression a
rewriteStaATS FixityState a
st = (Base (StaticExpression a) (StaticExpression a)
 -> StaticExpression a)
-> StaticExpression a -> StaticExpression a
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata Base (StaticExpression a) (StaticExpression a)
-> StaticExpression a
StaticExpressionF a (StaticExpression a) -> StaticExpression a
a where
    a :: StaticExpressionF a (StaticExpression a) -> StaticExpression a
a (SCallF Name a
n [[Type a]]
is [[Type a]]
ts [StaticVoid{}] Maybe [Expression a]
dyn) = Name a
-> [[Type a]]
-> [[Type a]]
-> [StaticExpression a]
-> Maybe [Expression a]
-> StaticExpression a
forall a.
Name a
-> [[Type a]]
-> [[Type a]]
-> [StaticExpression a]
-> Maybe [Expression a]
-> StaticExpression a
SCall Name a
n [[Type a]]
is [[Type a]]
ts [] Maybe [Expression a]
dyn
    a (StaticBinaryF BinOp a
op (StaticBinary BinOp a
op' StaticExpression a
e StaticExpression a
e') StaticExpression a
e'')
        | FixityState a -> BinOp a -> BinOp a -> Bool
forall a. Eq a => FixityState a -> BinOp a -> BinOp a -> Bool
compareFixity FixityState a
st BinOp a
op BinOp a
op'  = BinOp a
-> StaticExpression a -> StaticExpression a -> StaticExpression a
forall a.
BinOp a
-> StaticExpression a -> StaticExpression a -> StaticExpression a
StaticBinary BinOp a
op StaticExpression a
e (BinOp a
-> StaticExpression a -> StaticExpression a -> StaticExpression a
forall a.
BinOp a
-> StaticExpression a -> StaticExpression a -> StaticExpression a
StaticBinary BinOp a
op' StaticExpression a
e' StaticExpression a
e'')
    a (WhereStaExpF StaticExpression a
se (ATS [Declaration a]
ds))   = StaticExpression a -> ATS a -> StaticExpression a
forall a. StaticExpression a -> ATS a -> StaticExpression a
WhereStaExp StaticExpression a
se ([Declaration a] -> ATS a
forall a. [Declaration a] -> ATS a
ATS (FixityState a -> Declaration a -> Declaration a
forall a. Eq a => FixityState a -> Declaration a -> Declaration a
rewriteDecl FixityState a
st (Declaration a -> Declaration a)
-> [Declaration a] -> [Declaration a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration a]
ds))
    a (SPrecedeF StaticExpression a
e e' :: StaticExpression a
e'@SPrecedeList{})                 = [StaticExpression a] -> StaticExpression a
forall a. [StaticExpression a] -> StaticExpression a
SPrecedeList (StaticExpression a
e StaticExpression a -> [StaticExpression a] -> [StaticExpression a]
forall a. a -> [a] -> [a]
: StaticExpression a -> [StaticExpression a]
forall a. StaticExpression a -> [StaticExpression a]
_sExprs StaticExpression a
e')
    a (SPrecedeF StaticExpression a
e StaticExpression a
e')                                = [StaticExpression a] -> StaticExpression a
forall a. [StaticExpression a] -> StaticExpression a
SPrecedeList [StaticExpression a
e, StaticExpression a
e']
    a StaticExpressionF a (StaticExpression a)
x                                               = Base (StaticExpression a) (StaticExpression a)
-> StaticExpression a
forall t. Corecursive t => Base t t -> t
embed Base (StaticExpression a) (StaticExpression a)
StaticExpressionF a (StaticExpression a)
x

-- | Among other things, this rewrites expressions so that operator precedence
-- is respected; this ensures @1 + 2 * 3@ will be parsed as the correct
-- expression.
rewriteATS :: Eq a => FixityState a -> Expression a -> Expression a
rewriteATS :: FixityState a -> Expression a -> Expression a
rewriteATS FixityState a
st = (Base (Expression a) (Expression a) -> Expression a)
-> Expression a -> Expression a
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata Base (Expression a) (Expression a) -> Expression a
ExpressionF a (Expression a) -> Expression a
a where
    a :: ExpressionF a (Expression a) -> Expression a
a (LetF a
loc (ATS [Declaration a]
ds) Maybe (Expression a)
e')                         = a -> ATS a -> Maybe (Expression a) -> Expression a
forall a. a -> ATS a -> Maybe (Expression a) -> Expression a
Let a
loc ([Declaration a] -> ATS a
forall a. [Declaration a] -> ATS a
ATS (FixityState a -> Declaration a -> Declaration a
forall a. Eq a => FixityState a -> Declaration a -> Declaration a
rewriteDecl FixityState a
st (Declaration a -> Declaration a)
-> [Declaration a] -> [Declaration a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration a]
ds)) Maybe (Expression a)
e'
    a (CallF Name a
n [[Type a]]
ts [[Type a]]
ts' Maybe [Expression a]
me [ParenExpr a
_ e :: Expression a
e@NamedVal{}]) = Name a
-> [[Type a]]
-> [[Type a]]
-> Maybe [Expression a]
-> [Expression a]
-> Expression a
forall a.
Name a
-> [[Type a]]
-> [[Type a]]
-> Maybe [Expression a]
-> [Expression a]
-> Expression a
Call Name a
n [[Type a]]
ts [[Type a]]
ts' Maybe [Expression a]
me [Expression a
e]
    a (CallF Name a
n [[Type a]]
ts [[Type a]]
ts' Maybe [Expression a]
me [ParenExpr a
_ e :: Expression a
e@Call{}])     = Name a
-> [[Type a]]
-> [[Type a]]
-> Maybe [Expression a]
-> [Expression a]
-> Expression a
forall a.
Name a
-> [[Type a]]
-> [[Type a]]
-> Maybe [Expression a]
-> [Expression a]
-> Expression a
Call Name a
n [[Type a]]
ts [[Type a]]
ts' Maybe [Expression a]
me [Expression a
e]
    a (PrecedeF Expression a
e e' :: Expression a
e'@PrecedeList{})                  = [Expression a] -> Expression a
forall a. [Expression a] -> Expression a
PrecedeList (Expression a
e Expression a -> [Expression a] -> [Expression a]
forall a. a -> [a] -> [a]
: Expression a -> [Expression a]
forall a. Expression a -> [Expression a]
_exprs Expression a
e')
    a (PrecedeF Expression a
e Expression a
e')                                = [Expression a] -> Expression a
forall a. [Expression a] -> Expression a
PrecedeList [Expression a
e, Expression a
e']
    a (CallF Name a
n [[Type a]]
_ [[Type a]]
_ Maybe [Expression a]
_ [Unary (SpecialOp a
loc String
s) Expression a
e])    = BinOp a -> Expression a -> Expression a -> Expression a
forall a. BinOp a -> Expression a -> Expression a -> Expression a
Binary (a -> String -> BinOp a
forall a. a -> String -> BinOp a
SpecialInfix a
loc String
s) (Name a -> Expression a
forall a. Name a -> Expression a
NamedVal Name a
n) Expression a
e
    a (BinaryF BinOp a
op' (Binary BinOp a
op'' Expression a
e Expression a
e') Expression a
e'')
        | FixityState a -> BinOp a -> BinOp a -> Bool
forall a. Eq a => FixityState a -> BinOp a -> BinOp a -> Bool
compareFixity FixityState a
st BinOp a
op' BinOp a
op'' = BinOp a -> Expression a -> Expression a -> Expression a
forall a. BinOp a -> Expression a -> Expression a -> Expression a
Binary BinOp a
op'' Expression a
e (BinOp a -> Expression a -> Expression a -> Expression a
forall a. BinOp a -> Expression a -> Expression a -> Expression a
Binary BinOp a
op' Expression a
e' Expression a
e'')
    a (BinaryF BinOp a
Add Expression a
e (BinList BinOp a
Add [Expression a]
es))               = BinOp a -> [Expression a] -> Expression a
forall a. BinOp a -> [Expression a] -> Expression a
BinList BinOp a
forall a. BinOp a
Add (Expression a
e Expression a -> [Expression a] -> [Expression a]
forall a. a -> [a] -> [a]
: [Expression a]
es)
    a (BinaryF BinOp a
Add Expression a
e Expression a
e')                             = BinOp a -> [Expression a] -> Expression a
forall a. BinOp a -> [Expression a] -> Expression a
BinList BinOp a
forall a. BinOp a
Add [Expression a
e, Expression a
e']
    a (BinaryF Con{} Expression a
e (BinList BinOp a
Add [Expression a]
es))             = BinOp a -> [Expression a] -> Expression a
forall a. BinOp a -> [Expression a] -> Expression a
BinList (a -> String -> BinOp a
forall a. a -> String -> BinOp a
SpecialInfix a
forall a. HasCallStack => a
undefined String
"::") (Expression a
e Expression a -> [Expression a] -> [Expression a]
forall a. a -> [a] -> [a]
: [Expression a]
es)
    a (BinaryF Con{} Expression a
e Expression a
e')                           = BinOp a -> [Expression a] -> Expression a
forall a. BinOp a -> [Expression a] -> Expression a
BinList (a -> String -> BinOp a
forall a. a -> String -> BinOp a
SpecialInfix a
forall a. HasCallStack => a
undefined String
"::") [Expression a
e, Expression a
e']
    a (ParenExprF a
_ e :: Expression a
e@Precede{})                     = Expression a
e
    a (ParenExprF a
_ e :: Expression a
e@PrecedeList{})                 = Expression a
e
    a (WhereExpF Expression a
e (ATS [Declaration a]
ds))                         = Expression a -> ATS a -> Expression a
forall a. Expression a -> ATS a -> Expression a
WhereExp Expression a
e ([Declaration a] -> ATS a
forall a. [Declaration a] -> ATS a
ATS (FixityState a -> Declaration a -> Declaration a
forall a. Eq a => FixityState a -> Declaration a -> Declaration a
rewriteDecl FixityState a
st (Declaration a -> Declaration a)
-> [Declaration a] -> [Declaration a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration a]
ds))
    a (ActionsF (ATS [Declaration a]
ds))                            = ATS a -> Expression a
forall a. ATS a -> Expression a
Actions ([Declaration a] -> ATS a
forall a. [Declaration a] -> ATS a
ATS (FixityState a -> Declaration a -> Declaration a
forall a. Eq a => FixityState a -> Declaration a -> Declaration a
rewriteDecl FixityState a
st (Declaration a -> Declaration a)
-> [Declaration a] -> [Declaration a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration a]
ds))
    a ExpressionF a (Expression a)
x                                              = Base (Expression a) (Expression a) -> Expression a
forall t. Corecursive t => Base t t -> t
embed Base (Expression a) (Expression a)
ExpressionF a (Expression a)
x