swearjure-1.0.0: src/Swearjure/Reader.hs
{-# OPTIONS_GHC -Wall -Werror #-}
module Swearjure.Reader where
import Control.Applicative ((<$>), (<*>))
import Control.Monad.Except
import Control.Monad.State
import qualified Data.Generics.Fixplate as F
import Data.Generics.Fixplate hiding (mapM)
import Data.List (elemIndex)
import qualified Data.Map as M
import Data.Maybe (maybeToList, fromMaybe, isJust)
import Prelude hiding (seq)
import Swearjure.AST
import Swearjure.Errors
import Swearjure.Parser
readVal :: PVal -> EvalState Val
readVal ast = replaceFnLits ast >>= convertAst
convertAst :: PVal -> EvalState Val
convertAst = go
where go :: PVal -> EvalState Val
go = liftM Fix . goF . unFix
goF :: PValF PVal -> EvalState (SwjValF Val)
goF (PSym s) = return $ uncurry ESym $ splitSym s
goF (PString s) = return $ EStr s
goF (PKw s) = return $ uncurry EKw $ splitSym s
goF (PQualKw s) = return $ EKw (Just "user") s
-- -^ if we could move nses, this would've forced this fn to be of
-- EvalState
goF (PChar c) = return $ EChar c
-- TODO: Go over to compdata. Excellent fit here actually, as this
-- traversal is over a desugared ast.
goF (PFnLit _) = throwError $ IllegalState $ "Internal error: Function "
++ "literals should've been eradicated by now"
goF (PList xs) = EList <$> mapM go xs
goF (PVec xs) = EVec <$> mapM go xs
-- randomization of sets and hash maps
goF (PSet xs) = do vals <- mapM go xs
ESet <$> shuffle vals
-- want this to be Data.Set, but forces eq + ord on Mu/Attr
goF (PHM pairs) = do vals <- mapM (\(x, y) -> (,) <$> go x <*> go y) pairs
EHM <$> shuffle vals
goF (PSyntaxQuote x) = syntaxUnquote x >>= goF
splitSym :: String -> (Maybe String, String)
splitSym "/" = (Nothing, "/")
splitSym s = case '/' `elemIndex` s of
Nothing -> (Nothing, s)
Just idx -> let (ns, name) = splitAt idx s in
(Just ns, tail name)
replaceFnLits :: PVal -> EvalState PVal
replaceFnLits (Fix (PFnLit xs'))
= do xs <- replacePercents xs'
return $ Fix $ PList $ (Fix $ PSym "fn*") : xs
replaceFnLits (Fix x) = Fix <$> F.mapM replaceFnLits x
replacePercents :: [PVal] -> EvalState [PVal]
replacePercents e = prepareArglist <$> runStateT (mapM (cataM go) e)
(Nothing, Nothing)
where go (PSym "%")
= do (p1, r) <- get
case p1 of
Nothing -> do cnt <- lift get
lift $ modify succ
let p1s = p1sym cnt
put (Just p1s, r)
return p1s
(Just p1s) -> return p1s
go (PSym "%&")
= do (p1, r) <- get
case r of
Nothing -> do cnt <- lift get
lift $ modify succ
let rsym = restSym cnt
put (p1, Just rsym)
return rsym
(Just rsym) -> return rsym
go x = return $ Fix x
p1sym cnt = Fix $ PSym $ "p1__" ++ show cnt ++ "#"
restSym cnt = Fix $ PSym $ "rest__" ++ show cnt ++ "#"
prepareArglist (es, (p1, rest))
= let arglist = maybeToList p1 ++ restArglist rest in
[ (Fix . PVec) arglist
, (Fix . PList) es]
restArglist (Just rest) = [Fix $ PSym "&", rest]
restArglist Nothing = []
syntaxUnquote :: PVal -> EvalState (PValF PVal)
syntaxUnquote e = fst <$> runStateT (go $ unFix e) M.empty
where go :: PValF PVal -> StateT (M.Map String (PValF PVal)) EvalState (PValF PVal)
go sym@(PSym s)
| last s == '#'
= do r <- gets (M.lookup s)
case r of
Just replacement -> return replacement
Nothing ->
do symCnt <- lift get
lift $ modify succ
let gsym = PList [_pquote, gensym s symCnt]
modify $ M.insert s gsym
return gsym
| last s == '.' = throwError $ IllegalState "expansion of class ctors not implemented yet"
| head s == '.' = return $ PList [_pquote, Fix sym]
| isJust $ fst (splitSym s) = return $ PList [_pquote, Fix sym]
| otherwise = do newSym <- fromMaybe (Fix $ PSym $ "user/" ++ s)
<$> liftM (fmap $ Fix . deSym . unFix)
(getMapping s)
return $ PList [_pquote, newSym]
go lst@(PList []) = return lst
go (PList xs)
| head xs == _punquote = return $ unFix $ xs !! 1
| head xs == _punquoteSplicing
= throwError $ IllegalState "splice not in list"
| otherwise = do seq <- sqExpand xs
return $ PList [_pseq, iPList $ _pconcat : seq]
go (PVec xs)
= do seq <- sqExpand xs
return $ PList [_papply, _pvector,
iPList [_pseq, iPList $ _pconcat : seq]]
go (PSet xs)
= do seq <- sqExpand xs
return $ PList [_papply, _phashset,
iPList [_pseq, iPList $ _pconcat : seq]]
go (PHM pairs)
= do seq <- sqExpand (unpair pairs)
return $ PList [_papply, _phashmap,
iPList [_pseq, iPList $ _pconcat : seq]]
go x = return x
sqExpand = mapM (listGo . unFix)
listGo lst@(PList []) = return $ iPList [_plist, Fix lst]
listGo ls@(PList xs)
| head xs == _punquote = return $ iPList [_plist, xs !! 1]
| head xs == _punquoteSplicing
= return $ xs !! 1
| otherwise = do squote <- go ls
return $ iPList [_plist, Fix squote]
listGo x = do squote <- go x
return $ iPList [_plist, Fix squote]
unpair = concatMap (\(x,y) -> [x, y])
gensym s cnt = Fix $ PSym $ init s ++ "__"
++ show cnt ++ "__auto__"
-- TODO: This is hacky.
_pquote = Fix $ PSym "quote"
_punquote = Fix $ PSym "clojure.core/unquote"
_punquoteSplicing = Fix $ PSym "clojure.core/unquote-splicing"
_pconcat = Fix $ PSym "clojure.core/concat"
_papply = Fix $ PSym "clojure.core/apply"
_pvector = Fix $ PSym "clojure.core/vector"
_phashmap = Fix $ PSym "clojure.core/hash-map"
_phashset = Fix $ PSym "clojure.core/hash-set"
_plist = Fix $ PSym "clojure.core/list"
_pseq = Fix $ PSym "clojure.core/seq"
deSym (ESym a b) = PSym $ maybe "" (++ "/") a ++ b
deSym _ = error "getMapping returned non-sym back"
iPList = Fix . PList