{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Fay.Compiler.ModuleT
(
ModuleT
, getModuleInfo
, runModuleT
, MonadModule (..)
, ModName (..)
) where
import Fay.Compiler.Prelude
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Char as Char (isAlphaNum, isUpper)
import qualified Data.Map as Map
newtype ModuleName = ModuleName [String]
deriving (ModuleName -> ModuleName -> Bool
(ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool) -> Eq ModuleName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleName -> ModuleName -> Bool
$c/= :: ModuleName -> ModuleName -> Bool
== :: ModuleName -> ModuleName -> Bool
$c== :: ModuleName -> ModuleName -> Bool
Eq, Eq ModuleName
Eq ModuleName
-> (ModuleName -> ModuleName -> Ordering)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> Bool)
-> (ModuleName -> ModuleName -> ModuleName)
-> (ModuleName -> ModuleName -> ModuleName)
-> Ord ModuleName
ModuleName -> ModuleName -> Bool
ModuleName -> ModuleName -> Ordering
ModuleName -> ModuleName -> ModuleName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ModuleName -> ModuleName -> ModuleName
$cmin :: ModuleName -> ModuleName -> ModuleName
max :: ModuleName -> ModuleName -> ModuleName
$cmax :: ModuleName -> ModuleName -> ModuleName
>= :: ModuleName -> ModuleName -> Bool
$c>= :: ModuleName -> ModuleName -> Bool
> :: ModuleName -> ModuleName -> Bool
$c> :: ModuleName -> ModuleName -> Bool
<= :: ModuleName -> ModuleName -> Bool
$c<= :: ModuleName -> ModuleName -> Bool
< :: ModuleName -> ModuleName -> Bool
$c< :: ModuleName -> ModuleName -> Bool
compare :: ModuleName -> ModuleName -> Ordering
$ccompare :: ModuleName -> ModuleName -> Ordering
$cp1Ord :: Eq ModuleName
Ord, Int -> ModuleName -> ShowS
[ModuleName] -> ShowS
ModuleName -> String
(Int -> ModuleName -> ShowS)
-> (ModuleName -> String)
-> ([ModuleName] -> ShowS)
-> Show ModuleName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleName] -> ShowS
$cshowList :: [ModuleName] -> ShowS
show :: ModuleName -> String
$cshow :: ModuleName -> String
showsPrec :: Int -> ModuleName -> ShowS
$cshowsPrec :: Int -> ModuleName -> ShowS
Show)
fromString :: String -> ModuleName
fromString :: String -> ModuleName
fromString String
string
| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
validModuleComponent [String]
components' = [String] -> ModuleName
ModuleName [String]
components'
| Bool
otherwise = String -> ModuleName
forall a. HasCallStack => String -> a
error (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ String
"ModuleName.fromString: invalid module name " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
string
where
components' :: [String]
components' = String -> [String]
split String
string
split :: String -> [String]
split String
cs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') String
cs of
(String
chunk,[]) -> [String
chunk]
(String
chunk,Char
_:String
rest) -> String
chunk String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
split String
rest
validModuleComponent :: String -> Bool
validModuleComponent :: String -> Bool
validModuleComponent [] = Bool
False
validModuleComponent (Char
c:String
cs) = Char -> Bool
Char.isUpper Char
c
Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validModuleChar String
cs
validModuleChar :: Char -> Bool
validModuleChar :: Char -> Bool
validModuleChar Char
c = Char -> Bool
Char.isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''
class Monad m => MonadModule m where
type ModuleInfo m
lookupInCache :: ModName n => n -> m (Maybe (ModuleInfo m))
insertInCache :: ModName n => n -> ModuleInfo m -> m ()
readModuleInfo :: ModName n => [FilePath] -> n -> m (ModuleInfo m)
class ModName n where
modToString :: n -> String
instance ModName String where
modToString :: ShowS
modToString = ShowS
forall a. a -> a
id
convertModuleName :: ModName n => n -> ModuleName
convertModuleName :: n -> ModuleName
convertModuleName = String -> ModuleName
fromString (String -> ModuleName) -> (n -> String) -> n -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> String
forall n. ModName n => n -> String
modToString
getModuleInfo :: (MonadModule m, ModName n) => n -> m (Maybe (ModuleInfo m))
getModuleInfo :: n -> m (Maybe (ModuleInfo m))
getModuleInfo = n -> m (Maybe (ModuleInfo m))
forall (m :: * -> *) n.
(MonadModule m, ModName n) =>
n -> m (Maybe (ModuleInfo m))
lookupInCache
newtype ModuleT i m a =
ModuleT
(StateT (Map.Map ModuleName i)
(ReaderT ([FilePath] -> ModuleName -> m i) m) a)
deriving (a -> ModuleT i m b -> ModuleT i m a
(a -> b) -> ModuleT i m a -> ModuleT i m b
(forall a b. (a -> b) -> ModuleT i m a -> ModuleT i m b)
-> (forall a b. a -> ModuleT i m b -> ModuleT i m a)
-> Functor (ModuleT i m)
forall a b. a -> ModuleT i m b -> ModuleT i m a
forall a b. (a -> b) -> ModuleT i m a -> ModuleT i m b
forall i (m :: * -> *) a b.
Functor m =>
a -> ModuleT i m b -> ModuleT i m a
forall i (m :: * -> *) a b.
Functor m =>
(a -> b) -> ModuleT i m a -> ModuleT i m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ModuleT i m b -> ModuleT i m a
$c<$ :: forall i (m :: * -> *) a b.
Functor m =>
a -> ModuleT i m b -> ModuleT i m a
fmap :: (a -> b) -> ModuleT i m a -> ModuleT i m b
$cfmap :: forall i (m :: * -> *) a b.
Functor m =>
(a -> b) -> ModuleT i m a -> ModuleT i m b
Functor, Functor (ModuleT i m)
a -> ModuleT i m a
Functor (ModuleT i m)
-> (forall a. a -> ModuleT i m a)
-> (forall a b.
ModuleT i m (a -> b) -> ModuleT i m a -> ModuleT i m b)
-> (forall a b c.
(a -> b -> c) -> ModuleT i m a -> ModuleT i m b -> ModuleT i m c)
-> (forall a b. ModuleT i m a -> ModuleT i m b -> ModuleT i m b)
-> (forall a b. ModuleT i m a -> ModuleT i m b -> ModuleT i m a)
-> Applicative (ModuleT i m)
ModuleT i m a -> ModuleT i m b -> ModuleT i m b
ModuleT i m a -> ModuleT i m b -> ModuleT i m a
ModuleT i m (a -> b) -> ModuleT i m a -> ModuleT i m b
(a -> b -> c) -> ModuleT i m a -> ModuleT i m b -> ModuleT i m c
forall a. a -> ModuleT i m a
forall a b. ModuleT i m a -> ModuleT i m b -> ModuleT i m a
forall a b. ModuleT i m a -> ModuleT i m b -> ModuleT i m b
forall a b. ModuleT i m (a -> b) -> ModuleT i m a -> ModuleT i m b
forall a b c.
(a -> b -> c) -> ModuleT i m a -> ModuleT i m b -> ModuleT i m c
forall i (m :: * -> *). Monad m => Functor (ModuleT i m)
forall i (m :: * -> *) a. Monad m => a -> ModuleT i m a
forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> ModuleT i m b -> ModuleT i m a
forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> ModuleT i m b -> ModuleT i m b
forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m (a -> b) -> ModuleT i m a -> ModuleT i m b
forall i (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ModuleT i m a -> ModuleT i m b -> ModuleT i m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ModuleT i m a -> ModuleT i m b -> ModuleT i m a
$c<* :: forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> ModuleT i m b -> ModuleT i m a
*> :: ModuleT i m a -> ModuleT i m b -> ModuleT i m b
$c*> :: forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> ModuleT i m b -> ModuleT i m b
liftA2 :: (a -> b -> c) -> ModuleT i m a -> ModuleT i m b -> ModuleT i m c
$cliftA2 :: forall i (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ModuleT i m a -> ModuleT i m b -> ModuleT i m c
<*> :: ModuleT i m (a -> b) -> ModuleT i m a -> ModuleT i m b
$c<*> :: forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m (a -> b) -> ModuleT i m a -> ModuleT i m b
pure :: a -> ModuleT i m a
$cpure :: forall i (m :: * -> *) a. Monad m => a -> ModuleT i m a
$cp1Applicative :: forall i (m :: * -> *). Monad m => Functor (ModuleT i m)
Applicative, Applicative (ModuleT i m)
a -> ModuleT i m a
Applicative (ModuleT i m)
-> (forall a b.
ModuleT i m a -> (a -> ModuleT i m b) -> ModuleT i m b)
-> (forall a b. ModuleT i m a -> ModuleT i m b -> ModuleT i m b)
-> (forall a. a -> ModuleT i m a)
-> Monad (ModuleT i m)
ModuleT i m a -> (a -> ModuleT i m b) -> ModuleT i m b
ModuleT i m a -> ModuleT i m b -> ModuleT i m b
forall a. a -> ModuleT i m a
forall a b. ModuleT i m a -> ModuleT i m b -> ModuleT i m b
forall a b. ModuleT i m a -> (a -> ModuleT i m b) -> ModuleT i m b
forall i (m :: * -> *). Monad m => Applicative (ModuleT i m)
forall i (m :: * -> *) a. Monad m => a -> ModuleT i m a
forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> ModuleT i m b -> ModuleT i m b
forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> (a -> ModuleT i m b) -> ModuleT i m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ModuleT i m a
$creturn :: forall i (m :: * -> *) a. Monad m => a -> ModuleT i m a
>> :: ModuleT i m a -> ModuleT i m b -> ModuleT i m b
$c>> :: forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> ModuleT i m b -> ModuleT i m b
>>= :: ModuleT i m a -> (a -> ModuleT i m b) -> ModuleT i m b
$c>>= :: forall i (m :: * -> *) a b.
Monad m =>
ModuleT i m a -> (a -> ModuleT i m b) -> ModuleT i m b
$cp1Monad :: forall i (m :: * -> *). Monad m => Applicative (ModuleT i m)
Monad)
instance MonadTrans (ModuleT i) where
lift :: m a -> ModuleT i m a
lift = StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a
forall i (m :: * -> *) a.
StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a
ModuleT (StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a)
-> (m a
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a)
-> m a
-> ModuleT i m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ([String] -> ModuleName -> m i) m a
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ([String] -> ModuleName -> m i) m a
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a)
-> (m a -> ReaderT ([String] -> ModuleName -> m i) m a)
-> m a
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT ([String] -> ModuleName -> m i) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
instance MonadIO m => MonadIO (ModuleT i m) where
liftIO :: IO a -> ModuleT i m a
liftIO = StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a
forall i (m :: * -> *) a.
StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a
ModuleT (StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a)
-> (IO a
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a)
-> IO a
-> ModuleT i m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance (Functor m, Monad m) => MonadModule (ModuleT i m) where
type ModuleInfo (ModuleT i m) = i
lookupInCache :: n -> ModuleT i m (Maybe (ModuleInfo (ModuleT i m)))
lookupInCache n
n = StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
(Maybe i)
-> ModuleT i m (Maybe i)
forall i (m :: * -> *) a.
StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a
ModuleT (StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
(Maybe i)
-> ModuleT i m (Maybe i))
-> StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
(Maybe i)
-> ModuleT i m (Maybe i)
forall a b. (a -> b) -> a -> b
$ ModuleName -> Map ModuleName i -> Maybe i
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (n -> ModuleName
forall n. ModName n => n -> ModuleName
convertModuleName n
n) (Map ModuleName i -> Maybe i)
-> StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
(Map ModuleName i)
-> StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
(Maybe i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
(Map ModuleName i)
forall s (m :: * -> *). MonadState s m => m s
get
insertInCache :: n -> ModuleInfo (ModuleT i m) -> ModuleT i m ()
insertInCache n
n ModuleInfo (ModuleT i m)
i = StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) ()
-> ModuleT i m ()
forall i (m :: * -> *) a.
StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a
ModuleT (StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) ()
-> ModuleT i m ())
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) ()
-> ModuleT i m ()
forall a b. (a -> b) -> a -> b
$ (Map ModuleName i -> Map ModuleName i)
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map ModuleName i -> Map ModuleName i)
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) ())
-> (Map ModuleName i -> Map ModuleName i)
-> StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> i -> Map ModuleName i -> Map ModuleName i
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (n -> ModuleName
forall n. ModName n => n -> ModuleName
convertModuleName n
n) i
ModuleInfo (ModuleT i m)
i
readModuleInfo :: [String] -> n -> ModuleT i m (ModuleInfo (ModuleT i m))
readModuleInfo [String]
dirs n
mod' =
m i -> ModuleT i m i
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m i -> ModuleT i m i) -> ModuleT i m (m i) -> ModuleT i m i
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
([String] -> ModuleName -> m i)
-> ModuleT i m ([String] -> ModuleName -> m i)
forall i (m :: * -> *) a.
StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> ModuleT i m a
ModuleT StateT
(Map ModuleName i)
(ReaderT ([String] -> ModuleName -> m i) m)
([String] -> ModuleName -> m i)
forall r (m :: * -> *). MonadReader r m => m r
ask ModuleT i m ([String] -> ModuleName -> m i)
-> ModuleT i m [String] -> ModuleT i m (ModuleName -> m i)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [String] -> ModuleT i m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
dirs ModuleT i m (ModuleName -> m i)
-> ModuleT i m ModuleName -> ModuleT i m (m i)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ModuleName -> ModuleT i m ModuleName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (n -> ModuleName
forall n. ModName n => n -> ModuleName
convertModuleName n
mod')
runModuleT
:: (Monad m, Monoid i)
=> ModuleT i m a
-> m (a, Map.Map ModuleName i)
runModuleT :: ModuleT i m a -> m (a, Map ModuleName i)
runModuleT (ModuleT StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
a) =
ReaderT ([String] -> ModuleName -> m i) m (a, Map ModuleName i)
-> ([String] -> ModuleName -> m i) -> m (a, Map ModuleName i)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
-> Map ModuleName i
-> ReaderT ([String] -> ModuleName -> m i) m (a, Map ModuleName i)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT
(Map ModuleName i) (ReaderT ([String] -> ModuleName -> m i) m) a
a Map ModuleName i
forall k a. Map k a
Map.empty) (\[String]
_ ModuleName
_ -> i -> m i
forall (m :: * -> *) a. Monad m => a -> m a
return i
forall a. Monoid a => a
mempty)